Factors Influencing Public Transportation
GEOG 4/597: Advanced Spatial Quantitative
Analysis, Winter 2023
Afroza Hossain Misty | Portland State
University
Know about the study Area
Portland Metropolitian Area, Oregon
Demographics Distribution
tm_shape(s1) +
tm_polygons(
col = c('Whi', 'lat'),
lwd = 0.2,
border.col = 'grey80',
title = c("Spatial Distribution of White only Population ", "Spatial Distribution of Hispanic or Latino Population"),
palette = 'RdBu',
n=5,
alpha = 0.6,
midpoint = 0,
contrast =c(0,1),
style = 'quantile') +
tm_tiles("Stamen.TonerLabels") +
tm_layout(main.title = 'Portland Metro Area: Population Distribution')
White only and Hispanic Latino population have the highest percentage of the population.
Demographics Distribution
tm_shape(s1) +
tm_polygons(
col = c('Asi', 'Mix', 'Bla', 'Hawi'),
lwd = 0.2,
border.col = 'grey80',
title =c("Spatial Distribution of Asian Population", "Spatial Distribution of Two or More Races Population", "Spatial Distribution of Black Population", "Spatial Distribution of Native Hawaiian Population"),
palette = 'GnBu',
n=5,
alpha = 0.6,
midpoint = 0,
contrast =c(0,1),
style = 'quantile') +
tm_tiles("Stamen.TonerLabels") +
tm_layout(main.title = 'Portland Metro Area: Asian')
Public Transportation of Portland
Comparing Private Vehicle to Public Transportation
Public transport vs Private transport
moran_plot( #giving values to the function
var = t1$PuT,
w_var = t1$lag_PuT,
xlab = "Public Transport to Wrok(%)",
ylab = "Lag of Public Transport to Work(%)")## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
And we see a positive relationship between people who use public transport and their neighbors (here’s “lag”). This means that the neighbors of those who take public transport to work also use public transportation to work.
Median Household Income Vs Public Transportation to Work
#t3 %>% ggplot(aes(x=mhi, y=put)) +
t3 %>% ggplot(aes(x=mhi, y=put)) +
geom_point(color='royalblue', size=1) +
geom_smooth(
formula = 'y ~ x',
method = 'lm',
color="red",
size=0.8,
se=F) +
xlab("Median Household Income") +
ylab("Public Transportation to Work") +
ggtitle("Correlation of Variables")
oh! no… Negative !
Education Vs Public Transportation to Work
#merged_data %>% ggplot(aes(x=edu, y=put)) +
t3 %>% ggplot(aes(x=edu, y=put)) +
geom_point(color='royalblue', size=1) +
geom_smooth(
formula = 'y ~ x',
method = 'lm',
color="red",
size=0.8,
se=F) +
xlab("Education") +
ylab("Public Transportation to Work") +
ggtitle("Correlation of Variables")
Slightly Positive !
Household Size Vs Public Transportation to Work
t3 %>% ggplot(aes(x=hhs, y=put)) +
geom_point(color='royalblue', size=1) +
geom_smooth(
formula = 'y ~ x',
method = 'lm',
color="red",
size=0.8,
se=F) +
xlab("Household Size") +
ylab("Public Transportation to Work") +
ggtitle("Correlation of Variables")
Negative again!
Travel Time to work Vs Public Transportation to Work
#merged_data %>% ggplot(aes(x=ttw, y=put)) +
t3 %>% ggplot(aes(x=ttw, y=put)) +
geom_point(color='royalblue', size=1) +
geom_smooth(
formula = 'y ~ x',
method = 'lm',
color="red",
size=0.8,
se=F) +
xlab("Travel time to Work") +
ylab("Public Transportation to Work") +
ggtitle("Correlation of Variables")
Positive !
Race of the Population Vs Public Transportation to Work
#merged_data %>% ggplot(aes(x=rac, y=put)) +
t3 %>% ggplot(aes(x=rac, y=put)) +
geom_point(color='royalblue', size=1) +
geom_smooth(
formula = 'y ~ x',
method = 'lm',
color="red",
size=0.8,
se=F) +
xlab("Race of the Population") +
ylab("Public Transportation to Work") +
ggtitle("Correlation of Variables")
Negative !
Private Vehicle to work Vs Public Transportation to Work
#merged_data %>% ggplot(aes(x=prt, y=put)) +
t3 %>% ggplot(aes(x=prt, y=put)) +
geom_point(color='royalblue', size=1) +
geom_smooth(
formula = 'y ~ x',
method = 'lm',
color="red",
size=0.8,
se=F) +
xlab("Private Vehicle to Work") +
ylab("Public Transportation to Work") +
ggtitle("Correlation of Variables")
Strong Negative correlation!
Stops Location Vs Public Transportation to Work
#merged_data %>% ggplot(aes(x=put, y=put)) +
t3 %>% ggplot(aes(x=count_of_stops, y=put)) +
geom_point(color='royalblue', size=1) +
geom_smooth(
formula = 'y ~ x',
method = 'lm',
color="red",
size=0.8,
se=F) +
xlab("Private Vehicle to Work") +
ylab("Public Transportation to Work") +
ggtitle("Correlation of Variables")
Finally a proper Positive correlation
Isn’t it obvious?
No Vehicle Vs Public Transportation to Work
#merged_data %>% ggplot(aes(x=nov, y=put)) +
#t3 %>% ggplot(aes(x=nov, y=count_of_stops)) +
t3 %>% ggplot(aes(x=nov, y=put)) +
geom_point(color='royalblue', size=1) +
geom_smooth(
formula = 'y ~ x',
method = 'lm',
color="red",
size=0.8,
se=F) +
xlab("Tenure of vehicle_No vehicle") +
ylab("Public Transportation to Work") +
ggtitle("Correlation of Variables")
Its obvious too!!
APositive correlation
Here we can see the plotting our values with their Residuals
car::vif(mod)## mhi edu hhs ttw
## 2.310387 2.617762 1.841092 1.368497
## rac count_of_stops prt nov
## 1.563823 1.468361 1.531758 1.043644
## count_of_parks count_of_rests count_of_parkings
## 1.233374 1.407742 1.175481plot(mod, 3)
There are some large outlier which has made a trend with our residual.
Plotting it in the ggplot2 with residuals
data.frame(
residuals = mod$residuals^2 %>% sqrt(),
fitted = mod$fitted.values
) %>% ggplot(aes(x=fitted,y=residuals)) +
geom_point() +
xlab("Fitted Values") +
ylab("Standardized Residuals") +
geom_smooth(
method = 'gam',
col='red',se = FALSE) +
ggtitle("Residuals vs. Fitted Values")## `geom_smooth()` using formula = 'y ~ s(x, bs = "cs")'
There are more extreme points with the higher residuals rather than the lower ones.